home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / PAINT.ZIP / BITMAPS.PAS next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  7.3 KB  |  255 lines
  1. {************************************************}
  2. {                                                }
  3. {   ObjectWindows Paint demo                     }
  4. {   Copyright (c) 1992 by Borland International  }
  5. {                                                }
  6. {************************************************}
  7.  
  8. unit Bitmaps;
  9.  
  10. { This unit augments the HBitmap type by implementing load and store of the
  11.   bitmap to a file.
  12.  
  13.   Presently operates only on Windows format for bitmaps.
  14. }
  15. {$S-,R-}
  16.  
  17. interface
  18.  
  19. uses WinTypes, WinProcs;
  20.  
  21. { Read a bitmap from file (full pathname).
  22.   Returns 0 if error or HBitmap.
  23. }
  24. function LoadBitmapFile(FileName: PChar): HBitmap;
  25.  
  26. { Write a bitmap to file (full pathname).
  27.   Returns 0 if error else non-zero.
  28. }
  29. function StoreBitmapFile(FileName: PChar; HBM: HBitmap): Integer;
  30.  
  31. implementation
  32.  
  33. procedure AHIncr; far; external 'KERNEL' index 114;
  34.  
  35. const
  36.   OneIO = 32768;  { Number bytes handled per huge IO operation }
  37.   BMType = $4D42;  { = 'BM' }
  38.  
  39. type
  40.   PtrRec = record
  41.     Lo, Hi: Word
  42.   end;
  43.   IOFunction = function(FP: integer; Buf: PChar; Size: Integer): Word;
  44.  
  45. { Perform IO operation in chunks to avoid memory segment crossings.
  46.   Returns 0 if error else non-zero.
  47. }
  48. function HugeIO(IOFunc: IOFunction; F: Integer; P: Pointer; Size: Longint)
  49.                : Word;
  50. var
  51.   L, N: Longint;                { L maintains total bytes }
  52. begin                { N maintains bytes for current pass }
  53.   HugeIO := 1;
  54.   L := 0;
  55.   while L < Size do
  56.   begin
  57.     N := Size - L;
  58.     if N > OneIO then N := OneIO;
  59.     if IOFunc(F,
  60.     { Compute the segment and offset reached.
  61.       The Hi word of P contains the initial segment.
  62.       Think of the following as performing arithmetic
  63.         modulo segment-size, since the size of a segment
  64.         fills one word:
  65.       The Hi word of L contains the number of segments crossed
  66.         (the size of one segment fills the Lo word, so Hi word
  67.         will roll over as segments are filled).
  68.         Multiply by Ofs(AHIncr) to obtain the number used to
  69.         indicate this number of segments.
  70.       The Lo word of L contains the number of bytes already
  71.         passed in the present segment.
  72.      }
  73.            Ptr(PtrRec(P).Hi + PtrRec(L).Hi * Ofs(AHIncr),
  74.                PtrRec(L).Lo),
  75.                Integer(N))     { Guaranteed to be in Integer range }
  76.        <> N then
  77.     begin
  78.       HugeIO := 0;
  79.       Exit; { abnormal termination }
  80.     end; 
  81.     Inc(L, N);
  82.   end;
  83. end;
  84.  
  85. function _LFileSize(F : integer) : longint;        
  86. {- an equivalent to TP's FileSize() function }     
  87. var                                                
  88.   CurPos : longint;                                
  89. begin                                               
  90.   CurPos := _llseek(F,0,1);                    
  91.   _LFileSize := _llseek(F,0,2);                
  92.   _llseek(F,CurPos,0);                         
  93. end;                                           
  94.  
  95. { Read a bitmap from file (full pathname).
  96.   Returns 0 if error or HBitmap.
  97. }
  98. function LoadBitmapFile(FileName: PChar): HBitmap;
  99. var
  100.   F: Integer;            { File Handle for Windows file functions }
  101.   H: THandle;            { Handle to memory for bitmap }
  102.   DC: HDC;            { Drawing context for application }
  103.   Size, N: Longint;        { Size of bitmap, Size of color spec }
  104.   P: PBitmapInfo;        { Windows bitmap format info header }
  105.   Header: TBitmapFileHeader;    { Bitmap file header }
  106.  
  107. begin
  108.   LoadBitmapFile := 0;
  109.   F := _LOpen(FileName, of_Read);
  110.   if F = -1 then Exit;
  111.  
  112.   { read in the Bitmap file header }
  113.   if (_LRead(F, @Header, SizeOf(Header)) <> SizeOf(Header)) or
  114.     (Header.bfType <> BMType) then
  115.   begin
  116.     _LClose(F);
  117.     Exit;
  118.   end;
  119.  
  120.   { read the rest of the file }
  121.   Size := _LFileSize(F) - SizeOf(TBitmapFileHeader);     
  122.   H := GlobalAlloc(gmem_Moveable, Size);    { Allocate the memory }
  123.   if H = 0 then
  124.   begin
  125.     _LClose(F);
  126.     Exit;
  127.   end;
  128.  
  129.   P := GlobalLock(H);                { Lock it down }
  130.  
  131.   if (HugeIO(_LRead, F, P, Size) <> 0) and
  132.     (P^.bmiHeader.biSize = SizeOf(TBitmapInfoHeader)) then
  133.   begin
  134.     { Compute the offset from the beginning of P^ }      
  135.     { where the actual image begins }                    
  136.     N := Header.bfOffBits - SizeOf(TBitmapFileHeader);
  137.  
  138.     { actually create the Bitmap }
  139.     DC := GetDC(0);
  140.     LoadBitmapFile := CreateDIBitmap(DC, P^.bmiHeader,
  141.       cbm_Init, Ptr(PtrRec(P).Hi,N),P^, dib_RGB_Colors); 
  142.  
  143.     { clean up }
  144.     ReleaseDC(0, DC);
  145.   end;
  146.  
  147.   GlobalUnlock(H);
  148.   GlobalFree(H);
  149.   _LClose(F);
  150. end;
  151.  
  152.  
  153. { Write a bitmap to file (full pathname).
  154.   Returns 0 if error else non-zero.
  155. }
  156. function StoreBitmapFile(FileName: PChar; HBM: HBitmap): Integer;
  157.   var
  158.     BM:   TBitmap;        { Bitmap information }
  159.     BFH:  TBitmapFileHeader;    { Bitmap file information }
  160.     BIP:  PBitmapInfo;        { Part of bitmap file information }
  161.     DC:   HDC;            { Drawing context }
  162.  
  163.     HMem: THandle;        { Handle to memory for bitmap }
  164.     Buf:  Pointer;        { Memory for bitmap }
  165.  
  166.     ColorSize, DataSize: Longint; { Size needed to store Color/Data }
  167.     BitCount: Word;        { Number of bits per pixel }
  168.     FP: Integer;        { File }
  169.  
  170.   { Takes the size in bits and returns the (aligned) size in bytes.
  171.     Bitmap data format requires word alignment.
  172.   }
  173.   function bmAlignDouble(Size: Longint): Longint;
  174.   begin
  175.     bmAlignDouble := (Size + 31) div 32 * 4;
  176.   end;
  177.  
  178. begin
  179.    StoreBitmapFile := 0;
  180.    { Get the information about the Bitmap }
  181.    if GetObject(HBM, SizeOf(TBitmap), @BM) = 0 then Exit;
  182.  
  183.    BitCount := bm.bmPlanes * bm.bmBitsPixel;
  184.    if (BitCount <> 24) then
  185.      ColorSize := SizeOf(TRGBQuad) * (1 shl BitCount)
  186.    else
  187.      ColorSize := 0;
  188.    DataSize := bmAlignDouble(bm.bmWidth * BitCount) * bm.bmHeight;
  189.  
  190.    { Create the file }
  191.    FP := _lcreat(FileName, 0);
  192.    if FP = -1 then Exit;
  193.  
  194.    { Allocate memory for the bitmap info structure }
  195.    GetMem(BIP, SizeOf(TBitmapInfoHeader) + ColorSize);
  196.    if BIP <> nil then
  197.    begin
  198.      { Fill in the Bitmap info header }
  199.      with BIP^.bmiHeader do
  200.      begin
  201.        biSize := SizeOf(TBitmapInfoHeader);
  202.        biWidth := bm.bmWidth;
  203.        biHeight := bm.bmHeight;
  204.        biPlanes := 1;
  205.        biBitCount := BitCount;
  206.        biCompression := 0;
  207.        biSizeImage := DataSize;
  208.        biXPelsPerMeter := 0;
  209.        biYPelsPerMeter := 0;
  210.        biClrUsed := 0;
  211.        biClrImportant := 0;
  212.      end;
  213.  
  214.      { Fill in the file header }
  215.      with BFH do
  216.      begin
  217.        bfOffBits := SizeOf(BFH) + SizeOf(TBitmapInfo) + ColorSize;
  218.        bfReserved1 := 0;
  219.        bfReserved2 := 0;
  220.        bfSize :=  bfOffBits + DataSize;
  221.        bfType := BMType;
  222.      end;
  223.  
  224.      { Create the memory Bitmap }
  225.      HMem := GlobalAlloc(gmem_Fixed, DataSize);
  226.      if HMem <> 0 then
  227.      begin
  228.        Buf := GlobalLock(HMem);
  229.  
  230.        { Get the bitmap bits in device independent format }
  231.        DC := GetDC(0);
  232.        if GetDIBits(DC, hbm, 0, DataSize, Buf, BIP^, dib_RGB_Colors) <> 0 then
  233.        begin
  234.          ReleaseDC(0, DC);
  235.          { Write to file }
  236.          _lwrite(FP, @BFH, SizeOf(BFH));
  237.          _lwrite(FP, PChar(BIP), SizeOf(TBitmapInfo) + ColorSize);
  238.          HugeIO(_lwrite, FP, Buf, DataSize);
  239.          StoreBitmapFile := 1;
  240.        end;
  241.  
  242.        { Clean up }
  243.        GlobalUnlock(HMem);
  244.        GlobalFree(HMem);
  245.      end;
  246.  
  247.      FreeMem(BIP, SizeOf(TBitmapInfoHeader) + ColorSize);
  248.    end;
  249.  
  250.    _lclose(FP);
  251.  
  252. end;
  253.  
  254. end.
  255.